home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / 1.6.0 / ice-9 / debug.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  5.7 KB  |  165 lines
  1. ;;;;     Copyright (C) 1996, 1997, 1998, 1999, 2001 Free Software Foundation
  2. ;;;; 
  3. ;;;; This program is free software; you can redistribute it and/or modify
  4. ;;;; it under the terms of the GNU General Public License as published by
  5. ;;;; the Free Software Foundation; either version 2, or (at your option)
  6. ;;;; any later version.
  7. ;;;; 
  8. ;;;; This program is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. ;;;; GNU General Public License for more details.
  12. ;;;; 
  13. ;;;; You should have received a copy of the GNU General Public License
  14. ;;;; along with this software; see the file COPYING.  If not, write to
  15. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16. ;;;; Boston, MA 02111-1307 USA
  17. ;;;;
  18. ;;;; As a special exception, the Free Software Foundation gives permission
  19. ;;;; for additional uses of the text contained in its release of GUILE.
  20. ;;;;
  21. ;;;; The exception is that, if you link the GUILE library with other files
  22. ;;;; to produce an executable, this does not by itself cause the
  23. ;;;; resulting executable to be covered by the GNU General Public License.
  24. ;;;; Your use of that executable is in no way restricted on account of
  25. ;;;; linking the GUILE library code into it.
  26. ;;;;
  27. ;;;; This exception does not however invalidate any other reasons why
  28. ;;;; the executable file might be covered by the GNU General Public License.
  29. ;;;;
  30. ;;;; This exception applies only to the code released by the
  31. ;;;; Free Software Foundation under the name GUILE.  If you copy
  32. ;;;; code from other Free Software Foundation releases into a copy of
  33. ;;;; GUILE, as the General Public License permits, the exception does
  34. ;;;; not apply to the code that you add in this way.  To avoid misleading
  35. ;;;; anyone as to the status of such modified files, you must delete
  36. ;;;; this exception notice from them.
  37. ;;;;
  38. ;;;; If you write modifications of your own for GUILE, it is your choice
  39. ;;;; whether to permit this exception to apply to your modifications.
  40. ;;;; If you do not wish that, delete this exception notice.
  41. ;;;;
  42. ;;;; The author can be reached at djurfeldt@nada.kth.se
  43. ;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
  44. ;;;;
  45.  
  46.  
  47. (define-module (ice-9 debug)
  48.   :export (frame-number->index trace untrace trace-stack untrace-stack))
  49.  
  50.  
  51. ;;; {Misc}
  52. ;;;
  53. (define (frame-number->index n . stack)
  54.   (let ((stack (if (null? stack)
  55.            (fluid-ref the-last-stack)
  56.            (car stack))))
  57.     (if (memq 'backwards (debug-options))
  58.     n
  59.     (- (stack-length stack) n 1))))
  60.  
  61.  
  62. ;;; {Trace}
  63. ;;;
  64. ;;; This code is just an experimental prototype (e. g., it is not
  65. ;;; thread safe), but since it's at the same time useful, it's
  66. ;;; included anyway.
  67. ;;;
  68. (define traced-procedures '())
  69.  
  70. (define (trace . args)
  71.   (if (null? args)
  72.       (nameify traced-procedures)
  73.       (begin
  74.     (for-each (lambda (proc)
  75.             (if (not (procedure? proc))
  76.             (error "trace: Wrong type argument:" proc))
  77.             (set-procedure-property! proc 'trace #t)
  78.             (if (not (memq proc traced-procedures))
  79.             (set! traced-procedures
  80.                   (cons proc traced-procedures))))
  81.           args)
  82.     (trap-set! apply-frame-handler trace-entry)
  83.     (trap-set! exit-frame-handler trace-exit)
  84.     ;; We used to reset `trace-level' here to 0, but this is wrong
  85.     ;; if `trace' itself is being traced, since `trace-exit' will
  86.     ;; then decrement `trace-level' to -1!  It shouldn't actually
  87.     ;; be necessary to set `trace-level' here at all.
  88.     (debug-enable 'trace)
  89.     (nameify args))))
  90.  
  91. (define (untrace . args)
  92.   (if (and (null? args)
  93.        (not (null? traced-procedures)))
  94.       (apply untrace traced-procedures)
  95.       (begin
  96.     (for-each (lambda (proc)
  97.             (set-procedure-property! proc 'trace #f)
  98.             (set! traced-procedures (delq! proc traced-procedures)))
  99.           args)
  100.     (if (null? traced-procedures)
  101.         (debug-disable 'trace))
  102.     (nameify args))))
  103.  
  104. (define (nameify ls)
  105.   (map (lambda (proc)
  106.      (let ((name (procedure-name proc)))
  107.        (or name proc)))
  108.        ls))
  109.  
  110. (define trace-level 0)
  111. (add-hook! abort-hook (lambda () (set! trace-level 0)))
  112.  
  113. (define traced-stack-ids (list 'repl-stack))
  114. (define trace-all-stacks? #f)
  115.  
  116. (define (trace-stack id)
  117.   "Add ID to the set of stack ids for which tracing is active.
  118. If `#t' is in this set, tracing is active regardless of stack context.
  119. To remove ID again, use `untrace-stack'.  If you add the same ID twice
  120. using `trace-stack', you will need to remove it twice."
  121.   (set! traced-stack-ids (cons id traced-stack-ids))
  122.   (set! trace-all-stacks? (memq #t traced-stack-ids)))
  123.  
  124. (define (untrace-stack id)
  125.   "Remove ID from the set of stack ids for which tracing is active."
  126.   (set! traced-stack-ids (delq1! id traced-stack-ids))
  127.   (set! trace-all-stacks? (memq #t traced-stack-ids)))
  128.  
  129. (define (trace-entry key cont tail)
  130.   (if (or trace-all-stacks?
  131.       (memq (stack-id cont) traced-stack-ids))
  132.       (let ((cep (current-error-port))
  133.         (frame (last-stack-frame cont)))
  134.     (if (not tail)
  135.         (set! trace-level (+ trace-level 1)))
  136.     (let indent ((n trace-level))
  137.       (cond ((> n 1) (display "|  " cep) (indent (- n 1)))))
  138.     (display-application frame cep)
  139.     (newline cep)))
  140.   ;; It's not necessary to call the continuation since
  141.   ;; execution will continue if the handler returns
  142.   ;(cont #f)
  143.   )
  144.  
  145. (define (trace-exit key cont retval)
  146.   (if (or trace-all-stacks?
  147.       (memq (stack-id cont) traced-stack-ids))
  148.       (let ((cep (current-error-port)))
  149.     (set! trace-level (- trace-level 1))
  150.     (let indent ((n trace-level))
  151.       (cond ((> n 0) (display "|  " cep) (indent (- n 1)))))
  152.     (write retval cep)
  153.     (newline cep))))
  154.  
  155.  
  156. ;;; A fix to get the error handling working together with the module system.
  157. ;;;
  158. ;;; XXX - Still needed?
  159. (module-set! the-root-module 'debug-options debug-options)
  160.  
  161.  
  162.  
  163. (debug-enable 'debug)
  164. (read-enable 'positions)
  165.